home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir30 / dt100.zip / TBLOCK.LSP < prev    next >
Lisp/Scheme  |  1993-10-04  |  4KB  |  159 lines
  1. ; DrafTools   [Version 1.00] 9/25/93       
  2. ;
  3.  
  4. (defun SETSCALES (scale)
  5.   (setvar "DIMSCALE" (* (getvar "DIMSCALE") scale))
  6.   (setvar "LTSCALE" (* (getvar "LTSCALE") scale))
  7.   (setvar "TEXTSIZE" (* (getvar "DIMTXT") scale))
  8. )
  9.  
  10. (defun getdwgname ( / v1 v2)
  11.   (if
  12.     (zerop (getvar "DWGTITLED"))
  13.     ""
  14.     (progn
  15.       (setq v1 (strlen (setq v2 (getvar "DWGNAME"))))
  16.       (while (and (> v1 0) (/= "\\" (substr v2 v1 1)))
  17.         (setq v1 (1- v1))
  18.       )
  19.       (substr v2 (1+ v1))
  20.     )
  21.   )
  22. )
  23.  
  24. (defun getattribval (ent tag / ca t1)
  25.   (while (and ent (setq ent (entnext ent)))
  26.     (setq t1 (entget ent))
  27.     (if 
  28.       (and (= "ATTRIB" (cdr (assoc '0 t1))) (= tag (cdr (assoc '2 t1))))
  29.       (setq ent nil)
  30.       (setq t1 nil)
  31.     )
  32.   )  
  33.   (if t1 (cdr (assoc '1 t1)) t1)
  34. )
  35.  
  36. (defun pack (s / t1)
  37.   (if (= (type s) 'STR)
  38.     (progn
  39.       (setq t1 (strlen s))
  40.       (while (and (> t1 0) (= " " (substr s t1 1)) (setq t1 (1- t1))))
  41.       (if (= 0 t1) "" (substr s 1 t1))
  42.     )
  43.     ""
  44.   )
  45. )
  46.  
  47. (defun lookup (fname tag index field / fh totrec rec reclen fields t1 s)
  48.   (setq fields nil)
  49.   (if
  50.     (and
  51.       (or 
  52.         (setq fh (open (strcat (if *LISPPATH *LISPPATH "") fname) "r"))
  53.         (setq fh (open fname "r"))
  54.       )
  55.       (setq tag (pack (getattribval (if *TBATTRIB *TBATTRIB (entlast)) tag)))
  56.       (/= "" (pack tag))
  57.     )
  58.     (if
  59.       (and
  60.         (princ (strcat "\nSearching Database " fname " for " tag "..."))
  61.         (repeat 4 (read-char fh))
  62.         (setq totrec (read-char fh))
  63.         (setq t1 (read-char fh))
  64.         (setq totrec (+ totrec (* 256 t1)))
  65.         (setq t1 (read-char fh))
  66.         (setq totrec (+ totrec (* 65536 t1)))
  67.         (setq t1 (read-char fh))
  68.         (setq totrec (+ totrec (* 16777216 t1)))
  69.         (repeat 2 (read-char fh))
  70.         (setq reclen (read-char fh))
  71.         (setq t1 (read-char fh))
  72.         (setq reclen (+ reclen (* 256 t1)))
  73.         (repeat 20 (read-char fh))
  74.         (setq t1 (read-char fh))
  75.         (while (and t1 (/= t1 10))
  76.           (setq fields
  77.             (cons
  78.               (list
  79.                 (pack
  80.                   (substr
  81.                     (progn
  82.                       (setq rec (chr (if (zerop t1) 32 t1)))
  83.                       (repeat 31 
  84.                         (setq rec 
  85.                           (strcat 
  86.                             rec 
  87.                             (if 
  88.                               (setq t1 (read-char fh)) 
  89.                               (chr (if (zerop t1) 32 t1)) 
  90.                               " "
  91.                             )
  92.                           )
  93.                         )
  94.                       )
  95.                     )
  96.                     1
  97.                     11
  98.                   )
  99.                 )
  100.                 (if (= "" (setq t1 (substr rec 12 1))) nil t1)
  101.                 (setq t1 (ascii (substr rec 17 1)))
  102.                 (if fields (+ (last (car fields)) (nth 2 (car fields))) 1)
  103.               )
  104.               fields
  105.             )
  106.           )
  107.           (setq t1 (read-char fh))
  108.         )
  109.         (= "C" (cadr (assoc field fields)))
  110.         (= "C" (cadr (assoc index fields)))
  111.         (setq rec 1)
  112.         (while (and rec (<= rec totrec) (read-char fh))
  113.           (setq s "")
  114.           (repeat (1- reclen)
  115.             (setq s 
  116.               (strcat 
  117.                 s 
  118.                 (if 
  119.                   (setq t1 (read-char fh)) 
  120.                   (chr (if (zerop t1) 32 t1))
  121.                   " "
  122.                 )
  123.               )
  124.             )
  125.           )
  126.           (if
  127.             (= tag 
  128.               (pack 
  129.                 (substr 
  130.                   s 
  131.                   (nth 3 (assoc index fields)) 
  132.                   (nth 2 (assoc index fields))
  133.                 )
  134.               )
  135.             )
  136.             (not (setq rec nil))
  137.             (setq rec (1+ rec))
  138.           )
  139.         )
  140.         (setq rec 
  141.           (if rec 
  142.             "?N" 
  143.             (pack 
  144.               (substr 
  145.                 s 
  146.                 (nth 3 (assoc field fields)) 
  147.                 (nth 2 (assoc field fields))
  148.               )
  149.             )
  150.           )
  151.         )
  152.       )
  153.       (progn (close fh) rec)
  154.       "?E"
  155.     )
  156.     (if fh (progn (close fh) (if (= "" (pack tag)) "" "?A")) "?F")
  157.   )
  158. )
  159.